home *** CD-ROM | disk | FTP | other *** search
/ PC Users 1998 June / Cd Pc Users 9.iso / prog / inst / baslibs / basgdi.bas < prev    next >
Encoding:
BASIC Source File  |  1996-12-11  |  9.0 KB  |  313 lines
  1. Attribute VB_Name = "basGDI"
  2. Option Explicit
  3.  
  4. Private Const LF_FACESIZE = 32
  5.  
  6. Private Type LogFont
  7.         lfHeight As Long
  8.         lfWidth As Long
  9.         lfEscapement As Long
  10.         lfOrientation As Long
  11.         lfWeight As Long
  12.         lfItalic As Byte
  13.         lfUnderline As Byte
  14.         lfStrikeOut As Byte
  15.         lfCharSet As Byte
  16.         lfOutPrecision As Byte
  17.         lfClipPrecision As Byte
  18.         lfQuality As Byte
  19.         lfPitchAndFamily As Byte
  20.         lfFaceName As String * LF_FACESIZE
  21.  End Type
  22.  
  23. Private Declare Function CreateFontIndirect Lib "gdi32" Alias _
  24.    "CreateFontIndirectA" (lpLogFont As LogFont) As Long
  25.    
  26. Private Declare Function DeleteObject Lib "gdi32" _
  27.    (ByVal hObject As Long) As Long
  28.    
  29. Private Declare Function SelectObject Lib "gdi32" _
  30.    (ByVal hdc As Long, ByVal hObject As Long) As Long
  31.  
  32. Private Declare Function SetBkMode Lib "gdi32" _
  33.    (ByVal hdc As Long, ByVal nBkMode As Long) As Long
  34.    
  35. Private Const TRANSPARENT = 1
  36. Private Const OPAQUE = 2
  37.  
  38. Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, _
  39.    ByVal nIndex As Long) As Long
  40.    
  41. Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
  42.  
  43. Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, _
  44.    ByVal hdc As Long) As Long
  45.    
  46. Private Declare Function GetDesktopWindow Lib "user32" () As Long
  47.  
  48. Private Type TEXTMETRIC
  49.    tmHeight As Integer
  50.    tmAscent As Integer
  51.    tmDescent As Integer
  52.    tmInternalLeading As Integer
  53.    tmExternalLeading As Integer
  54.    tmAveCharWidth As Integer
  55.    tmMaxCharWidth As Integer
  56.    tmWeight As Integer
  57.    tmItalic As String * 1
  58.    tmUnderlined As String * 1
  59.    tmStruckOut As String * 1
  60.    tmFirstChar As String * 1
  61.    tmLastChar As String * 1
  62.    tmDefaultChar As String * 1
  63.    tmBreakChar As String * 1
  64.    tmPitchAndFamily As String * 1
  65.    tmCharSet As String * 1
  66.    tmOverhang As Integer
  67.    tmDigitizedAspectX As Integer
  68.    tmDigitizedAspectY As Integer
  69. End Type
  70.  
  71. Private Declare Function GetTextMetrics Lib "gdi32" Alias "GetTextMetricsA" _
  72.   (ByVal hdc As Long, lpMetrics As TEXTMETRIC) As Long
  73.   
  74. Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
  75.  
  76. Private Declare Function SetMapMode Lib "gdi32" (ByVal hdc As Long, _
  77.    ByVal nMapMode As Long) As Long
  78.  
  79. Private Const MM_TEXT = 1
  80.  
  81. ' Constants for get device caps
  82. Private Const PHYSICALOFFSETX = 112
  83. Private Const PHYSICALOFFSETY = 113
  84. Private Const PLANES = 14
  85. Private Const BITSPIXEL = 12
  86.    
  87. Public Const MARGIN_TOP = 1
  88. Public Const MARGIN_BOTTOM = 2
  89. Public Const MARGIN_LEFT = 3
  90. Public Const MARGIN_RIGHT = 4
  91.  
  92.  
  93. Private Type RECT
  94.    Left As Long
  95.    Top As Long
  96.    Right As Long
  97.    Bottom As Long
  98. End Type
  99.  
  100. Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
  101. Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
  102.  
  103. '
  104. ' Gets the minumum margins for the printer.
  105. ' All returned values are in twips.
  106. ' It should also be noted the physical location 0,0
  107. ' of the printer object falls at the minimum top and left
  108. ' margins.
  109. '
  110. Public Function GetPrinterMinMargin(ByVal t As Integer) As Long
  111.    Select Case t
  112.     Case MARGIN_TOP:
  113.        GetPrinterMinMargin = GetDeviceCaps(Printer.hdc, PHYSICALOFFSETY) _
  114.            * Printer.TwipsPerPixelY
  115.     Case MARGIN_BOTTOM:
  116.        GetPrinterMinMargin = _
  117.           Printer.Height - Printer.ScaleHeight - _
  118.           (GetDeviceCaps(Printer.hdc, PHYSICALOFFSETY) * Printer.TwipsPerPixelY)
  119.     Case MARGIN_LEFT:
  120.        GetPrinterMinMargin = GetDeviceCaps(Printer.hdc, PHYSICALOFFSETX) _
  121.            * Printer.TwipsPerPixelX
  122.        
  123.     Case MARGIN_RIGHT:
  124.        GetPrinterMinMargin = _
  125.           Printer.Width - Printer.ScaleWidth - _
  126.           GetDeviceCaps(Printer.hdc, PHYSICALOFFSETX) * Printer.TwipsPerPixelX
  127.    
  128.     Case Else
  129.        ' There's an error
  130.        GetPrinterMinMargin = -1
  131.     End Select
  132. End Function
  133.  
  134. '
  135. ' Shades the form in a similar manner to many
  136. ' install programs.
  137. '
  138. ' Optional Arguments:
  139. ' StartColor is what color to start with.
  140. '   (Default = vbBlue)
  141. ' Fstep is the number of steps to use to fill the form.
  142. '   (Default = 64)
  143. ' Cstep is the color step (change in color per step).
  144. '   (Default = 4)
  145. '
  146. ' Note: the effect can be reversed by calling ShadeForm with
  147. '    a StartColor near black (but not completely 0) and by
  148. '    setting a negative color step.
  149. '
  150. Public Sub ShadeForm(f As Form, Optional StartColor As Variant, Optional Fstep As Variant, Optional Cstep As Variant)
  151.    Dim FillStep As Single  ' Not an integer because sometimes
  152.                            ' rounding leaves a large bottom region
  153.    Dim c As Long
  154.    Dim FillArea As RECT
  155.    Dim i As Integer
  156.    Dim oldm As Integer
  157.    Dim hBrush As Long
  158.    Dim c2(1 To 3) As Long
  159.    Dim cs2(1 To 3) As Long
  160.    Dim fs As Long
  161.    Dim cs As Integer
  162.       
  163.    ' Set defaults
  164.    fs = IIf(IsMissing(Fstep), 64, CLng(Fstep))
  165.    cs = IIf(IsMissing(Cstep), 4, CInt(Cstep))
  166.    c = IIf(IsMissing(StartColor), vbBlue, CLng(StartColor))
  167.    
  168.    
  169.    oldm = f.ScaleMode
  170.    f.ScaleMode = vbPixels
  171.    FillStep = f.ScaleHeight / fs
  172.    FillArea.Left = 0
  173.    FillArea.Right = f.ScaleWidth
  174.    FillArea.Top = 0
  175.  
  176.    ' Break down the color and set individual
  177.    ' color steps
  178.    c2(1) = c And 255#
  179.    cs2(1) = IIf(c2(1) > 0, cs, 0)
  180.    c2(2) = (c \ 256#) And 255#
  181.    cs2(2) = IIf(c2(2) > 0, cs, 0)
  182.    c2(3) = (c \ 65536#) And 255#
  183.    cs2(3) = IIf(c2(3) > 0, cs, 0)
  184.    
  185.    
  186.    For i = 1 To fs
  187.       FillArea.Bottom = FillStep * i
  188.  
  189.       hBrush = CreateSolidBrush(RGB(c2(1), c2(2), c2(3)))
  190.       FillRect f.hdc, FillArea, hBrush
  191.       DeleteObject hBrush
  192.       
  193.       ' Could do this in a loop, but it's simple
  194.       ' and may be faster.
  195.       c2(1) = (c2(1) - cs2(1)) And 255#
  196.       c2(2) = (c2(2) - cs2(2)) And 255#
  197.       c2(3) = (c2(3) - cs2(3)) And 255#
  198.       
  199.       FillArea.Top = FillArea.Bottom
  200.    Next i
  201.    
  202.    f.ScaleMode = oldm
  203. End Sub
  204.  
  205. '
  206. '  Returns true if the system is using small fonts,
  207. '  false if using large fonts
  208. '
  209. '  Source: the MS knowlege base article Q152136.
  210. '
  211. Public Function SmallFonts() As Boolean
  212.    Dim hdc As Long
  213.    Dim hwnd As Long
  214.    Dim PrevMapMode As Long
  215.    Dim tm As TEXTMETRIC
  216.  
  217.    ' Set the default return value to small fonts
  218.    SmallFonts = True
  219.    
  220.    ' Get the handle of the desktop window
  221.    hwnd = GetDesktopWindow()
  222.  
  223.    ' Get the device context for the desktop
  224.    hdc = GetWindowDC(hwnd)
  225.    If hdc Then
  226.       ' Set the mapping mode to pixels
  227.       PrevMapMode = SetMapMode(hdc, MM_TEXT)
  228.       
  229.       ' Get the size of the system font
  230.       GetTextMetrics hdc, tm
  231.  
  232.       ' Set the mapping mode back to what it was
  233.       PrevMapMode = SetMapMode(hdc, PrevMapMode)
  234.  
  235.       ' Release the device context
  236.       ReleaseDC hwnd, hdc
  237.      
  238.       ' If the system font is more than 16 pixels high,
  239.       ' then large fonts are being used
  240.       If tm.tmHeight > 16 Then SmallFonts = False
  241.    End If
  242.  
  243. End Function
  244. '
  245. ' Returns the number of colors in the display.
  246. '
  247. Public Function GetNColors() As Long
  248.   Dim hSrcDC As Integer
  249.  
  250.   hSrcDC = GetDC(GetDesktopWindow())
  251.   GetNColors = GetDeviceCaps(hSrcDC, PLANES) * 2 ^ GetDeviceCaps(hSrcDC, BITSPIXEL)
  252.   Call ReleaseDC(GetDesktopWindow(), hSrcDC)
  253. End Function
  254. '
  255. ' ob is a form, printer, or picturbox object
  256. ' You MUST call RestoreText with the handles (array)
  257. ' It should be called immediately after printing
  258. ' the rotated text and before changing any fonts, etc.
  259. ' or a leak in GDI resourses may occur.
  260. '
  261. ' Note:  When printing rotated fonts to the printer
  262. '        the .Transparent property is apparently ignored.
  263. '        Use the SetTransparent() function to fix this.
  264. '
  265. ' Bug: This doesn't work yet on forms or imageboxes :(
  266. Public Function RotateText(ob As Object, ByVal angle As Single) As Variant
  267.    Dim t As LogFont
  268.    Dim i As Long
  269.    Dim v(1 To 2) As Variant
  270.    
  271.    If ob Is Printer Then
  272.       t.lfHeight = ob.FontSize * -20 / Printer.TwipsPerPixelY
  273.    Else
  274.       t.lfHeight = ob.FontSize * -20 / Screen.TwipsPerPixelY
  275.    End If
  276.    
  277.    t.lfWidth = 0
  278.    t.lfEscapement = CLng(angle * 10#)
  279.    t.lfOrientation = t.lfEscapement
  280.    t.lfWeight = ob.Font.Weight
  281.    t.lfItalic = IIf(ob.FontItalic, 255, 0)
  282.    t.lfUnderline = IIf(ob.FontUnderline, 255, 0)
  283.    t.lfStrikeOut = IIf(ob.FontStrikethru, 255, 0)
  284.    t.lfCharSet = 0
  285.    t.lfOutPrecision = 0
  286.    t.lfClipPrecision = 0
  287.    t.lfQuality = 0
  288.    t.lfPitchAndFamily = 0
  289.    t.lfFaceName = ob.FontName & Chr$(0)
  290.  
  291.    i = CreateFontIndirect(t)
  292.       
  293.    v(1) = SelectObject(ob.hdc, i)
  294.    v(2) = i
  295.    
  296.    RotateText = v
  297. End Function
  298. '
  299. ' Usually the same as ob.Transparent = t except that
  300. ' rotated fonts apparently ignore this object with
  301. ' the printer object.
  302. '
  303. Public Sub SetTransparent(ob As Object, ByVal t As Boolean)
  304.    Call SetBkMode(ob.hdc, IIf(t, TRANSPARENT, OPAQUE))
  305. End Sub
  306.  
  307. Public Sub RestoreText(ob As Object, handles As Variant)
  308.    SelectObject ob.hdc, CLng(handles(1))
  309.    DeleteObject CLng(handles(2))
  310. End Sub
  311.  
  312.  
  313.